home *** CD-ROM | disk | FTP | other *** search
/ Windows Game Programming for Dummies (2nd Edition) / WinGamProgFD.iso / pc / DirectX SDK / DXSDK / samples / Multimedia / VBSamples / DirectPlay / DXVBMessenger / Server / frmServer.frm (.txt) next >
Encoding:
Visual Basic Form  |  2001-10-08  |  16.1 KB  |  376 lines
  1. VERSION 5.00
  2. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  3. Begin VB.Form frmServer 
  4.    BorderStyle     =   3  'Fixed Dialog
  5.    Caption         =   "vbMessenger Server"
  6.    ClientHeight    =   4515
  7.    ClientLeft      =   45
  8.    ClientTop       =   330
  9.    ClientWidth     =   3645
  10.    Icon            =   "frmServer.frx":0000
  11.    LinkTopic       =   "Form1"
  12.    MaxButton       =   0   'False
  13.    MinButton       =   0   'False
  14.    ScaleHeight     =   4515
  15.    ScaleWidth      =   3645
  16.    StartUpPosition =   3  'Windows Default
  17.    Begin VB.Timer tmrSaveXML 
  18.       Interval        =   60000
  19.       Left            =   3660
  20.       Top             =   1410
  21.    End
  22.    Begin VB.Timer tmrLogon 
  23.       Interval        =   50
  24.       Left            =   3660
  25.       Top             =   960
  26.    End
  27.    Begin VB.Timer tmrLogoff 
  28.       Interval        =   50
  29.       Left            =   3660
  30.       Top             =   480
  31.    End
  32.    Begin VB.ListBox lstUsers 
  33.       Height          =   3765
  34.       Left            =   60
  35.       TabIndex        =   1
  36.       Top             =   360
  37.       Width           =   3495
  38.    End
  39.    Begin MSComctlLib.StatusBar sBar 
  40.       Align           =   2  'Align Bottom
  41.       Height          =   375
  42.       Left            =   0
  43.       TabIndex        =   0
  44.       Top             =   4140
  45.       Width           =   3645
  46.       _ExtentX        =   6429
  47.       _ExtentY        =   661
  48.       Style           =   1
  49.       SimpleText      =   " "
  50.       _Version        =   393216
  51.       BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
  52.          NumPanels       =   1
  53.          BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
  54.          EndProperty
  55.       EndProperty
  56.    End
  57.    Begin VB.Label Label1 
  58.       BackStyle       =   0  'Transparent
  59.       Caption         =   "Users currently in this session"
  60.       Height          =   255
  61.       Left            =   60
  62.       TabIndex        =   2
  63.       Top             =   60
  64.       Width           =   3495
  65.    End
  66.    Begin VB.Menu mnuPop 
  67.       Caption         =   "PopUp"
  68.       Visible         =   0   'False
  69.       Begin VB.Menu mnuShow 
  70.          Caption         =   "Show"
  71.       End
  72.       Begin VB.Menu mnuSep 
  73.          Caption         =   "-"
  74.       End
  75.       Begin VB.Menu mnuExit 
  76.          Caption         =   "Exit"
  77.       End
  78.    End
  79. Attribute VB_Name = "frmServer"
  80. Attribute VB_GlobalNameSpace = False
  81. Attribute VB_Creatable = False
  82. Attribute VB_PredeclaredId = True
  83. Attribute VB_Exposed = False
  84. Option Explicit
  85. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  86. '  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
  87. '  File:       frmServer.frm
  88. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  89. Implements DirectPlay8Event
  90. Private mfExit As Boolean
  91. Private mfLogoffTimer As Boolean
  92. Private msLogoffName As String
  93. Private mfLogonTimer As Boolean
  94. Private msLogonName As String
  95. Private Sub StartServer()
  96.     Dim appdesc As DPN_APPLICATION_DESC
  97.     'Now set up the app description
  98.     With appdesc
  99.         .guidApplication = AppGuid
  100.         .lMaxPlayers = 1000 'This seems like a nice round number
  101.         .SessionName = "vbMessengerServer"
  102.         .lFlags = DPNSESSION_CLIENT_SERVER Or DPNSESSION_NODPNSVR 'We must pass the client server flags if we are a server
  103.     End With
  104.     'Now set up our address value
  105.     dpa.SetSP DP8SP_TCPIP
  106.     dpa.AddComponentLong DPN_KEY_PORT, glDefaultPort 'Use a specific port
  107.     'Now start the server
  108.     dps.Host appdesc, dpa
  109.     UpdateText "Server running...  (" & CStr(glNumPlayers) & "/1000 clients connected.)"
  110. End Sub
  111. Private Sub Form_Load()
  112.     dps.RegisterMessageHandler Me
  113.     'Lets put an icon in the system tray
  114.     With sysIcon
  115.         .cbSize = LenB(sysIcon)
  116.         .hwnd = Me.hwnd
  117.         .uFlags = NIF_DOALL
  118.         .uCallbackMessage = WM_MOUSEMOVE
  119.         .hIcon = Me.Icon
  120.         .sTip = "Server running...  (" & CStr(glNumPlayers) & "/1000 clients connected.)" & vbNullChar
  121.     End With
  122.     Shell_NotifyIcon NIM_ADD, sysIcon
  123.     'Open the database
  124.     OpenClientDatabase
  125.     'Start the server
  126.     StartServer
  127. End Sub
  128. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  129.     Dim ShellMsg As Long
  130.     ShellMsg = X / Screen.TwipsPerPixelX
  131.     Select Case ShellMsg
  132.     Case WM_LBUTTONDBLCLK
  133.         mnuShow_Click
  134.     Case WM_RBUTTONUP
  135.         'Show the menu
  136.         PopupMenu mnuPop, , , , mnuShow
  137.     End Select
  138. End Sub
  139. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  140.     If Not mfExit Then
  141.         Cancel = 1
  142.         Me.Hide
  143.     End If
  144. End Sub
  145. Private Sub Form_Unload(Cancel As Integer)
  146.     'Remove the icon from the system tray
  147.     Shell_NotifyIcon NIM_DELETE, sysIcon
  148.     'Close the database
  149.     CloseDownDB
  150.     'Cleanup the dplay objects
  151.     Cleanup
  152. End Sub
  153. Private Sub mnuExit_Click()
  154.     mfExit = True
  155.     Unload Me
  156. End Sub
  157. Private Sub mnuShow_Click()
  158.     Me.Visible = True
  159.     Me.SetFocus
  160. End Sub
  161. Private Sub tmrSaveXML_Timer()
  162.     Static lCount As Long
  163.     'Every 5 minutes we will save the xml
  164.     lCount = lCount + 1
  165.     If lCount >= 5 Then
  166.         lCount = 0
  167.         SaveXMLStructure
  168.     End If
  169. End Sub
  170. Private Sub UpdateText(sNewText As String)
  171.     sBar.SimpleText = sNewText
  172.     'modify our icon text
  173.     sysIcon.sTip = sNewText & vbNullChar
  174.     sysIcon.uFlags = NIF_TIP
  175.     Shell_NotifyIcon NIM_MODIFY, sysIcon
  176. End Sub
  177. Private Sub tmrLogoff_Timer()
  178.     'Log this user off
  179.     If mfLogoffTimer Then
  180.         NotifyFriends msLogoffName, Msg_FriendLogoff
  181.     End If
  182.     msLogoffName = vbNullString
  183.     mfLogoffTimer = False
  184. End Sub
  185. Private Sub tmrLogon_Timer()
  186.     If mfLogonTimer Then
  187.         mfLogonTimer = False
  188.         NotifyFriends msLogonName, Msg_FriendLogon 'Tell everyone who has me marked as a friend that I'm online
  189.         GetFriendsOfMineOnline msLogonName 'Find out if any of my friends are online and tell me
  190.     End If
  191.     msLogonName = vbNullString
  192. End Sub
  193. Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
  194.     'VB requires that we must implement *every* member of this interface
  195. End Sub
  196. Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
  197.     'VB requires that we must implement *every* member of this interface
  198. End Sub
  199. Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
  200.     'VB requires that we must implement *every* member of this interface
  201. End Sub
  202. Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
  203.     'VB requires that we must implement *every* member of this interface
  204. End Sub
  205. Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
  206.     'VB requires that we must implement *every* member of this interface
  207. End Sub
  208. Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
  209.     'VB requires that we must implement *every* member of this interface
  210. End Sub
  211. Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
  212.     'VB requires that we must implement *every* member of this interface
  213. End Sub
  214. Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
  215.     Dim lCount As Long
  216.     On Local Error GoTo ErrOut 'So we don't get an InvalidPlayer error when checking on the host
  217.     'Update the DB to show a logoff
  218.     UpdateDBToShowLogoff lPlayerID
  219.     'Remove this player from our listbox
  220.     For lCount = lstUsers.ListCount - 1 To 0 Step -1
  221.         If lstUsers.ItemData(lCount) = lPlayerID Then
  222.             mfLogoffTimer = True
  223.             msLogoffName = lstUsers.List(lCount)
  224.             glNumPlayers = glNumPlayers - 1
  225.             lstUsers.RemoveItem lCount
  226.             Exit For
  227.         End If
  228.     Next
  229. ErrOut:
  230.     UpdateText "Server running...  (" & CStr(glNumPlayers) & "/1000 clients connected.)"
  231. End Sub
  232. Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
  233.     'VB requires that we must implement *every* member of this interface
  234. End Sub
  235. Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
  236.     'VB requires that we must implement *every* member of this interface
  237. End Sub
  238. Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
  239.     'VB requires that we must implement *every* member of this interface
  240. End Sub
  241. Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
  242.     'VB requires that we must implement *every* member of this interface
  243. End Sub
  244. Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
  245.     'VB requires that we must implement *every* member of this interface
  246. End Sub
  247. Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
  248.     'VB requires that we must implement *every* member of this interface
  249. End Sub
  250. Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
  251.     'We need to get each message we receive from a client, process it, and respond accordingly
  252.     Dim lMsg As Long, lOffset As Long
  253.     Dim oNewMsg() As Byte, lNewOffSet As Long
  254.     Dim sUserName As String, sPass As String
  255.     Dim lNewMsg As Long, fLoggedin As Boolean
  256.     Dim sChatMsg As String, sFromMsg As String
  257.     With dpnotify
  258.     GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
  259.     Select Case lMsg 'The server will only receive certain messages.  Handle those.
  260.     Case Msg_AddFriend 'They want to add a friend to their list
  261.         sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
  262.         If Not DoesUserExist(sUserName) Then
  263.             'This user does not exist, notify the person that they cannot be added
  264.             lNewMsg = Msg_FriendDoesNotExist
  265.             lNewOffSet = NewBuffer(oNewMsg)
  266.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  267.             dps.SendTo .idSender, oNewMsg, 0, 0
  268.         Else
  269.             'Great, add this user to our friend list
  270.             fLoggedin = AddFriend(.idSender, sUserName, True)
  271.             lNewMsg = Msg_FriendAdded
  272.             lNewOffSet = NewBuffer(oNewMsg)
  273.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  274.             AddStringToBuffer oNewMsg, sUserName, lNewOffSet
  275.             dps.SendTo .idSender, oNewMsg, 0, DPNSEND_SYNC
  276.             If fLoggedin Then
  277.                 lNewMsg = Msg_FriendLogon
  278.                 lNewOffSet = NewBuffer(oNewMsg)
  279.                 AddDataToBuffer oNewMsg, lNewMsg, LenB(lMsg), lNewOffSet
  280.                 AddStringToBuffer oNewMsg, sUserName, lNewOffSet
  281.                 dps.SendTo .idSender, oNewMsg, 0, 0
  282.             End If
  283.         End If
  284.     Case Msg_BlockFriend 'They want to block a friend from their list
  285.         sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
  286.         If Not DoesUserExist(sUserName) Then
  287.             'This user does not exist, notify the person that they cannot be blocked
  288.             lNewMsg = Msg_BlockUserDoesNotExist
  289.             lNewOffSet = NewBuffer(oNewMsg)
  290.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  291.             dps.SendTo .idSender, oNewMsg, 0, 0
  292.         Else
  293.             'Great, block this user in our friend list
  294.             AddFriend .idSender, sUserName, False
  295.             lNewMsg = Msg_FriendBlocked
  296.             lNewOffSet = NewBuffer(oNewMsg)
  297.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  298.             AddStringToBuffer oNewMsg, sUserName, lNewOffSet
  299.             dps.SendTo .idSender, oNewMsg, 0, 0
  300.         End If
  301.     Case Msg_CreateNewAccount 'They want to create a new account
  302.         sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
  303.         sPass = GetStringFromBuffer(.ReceivedData, lOffset)
  304.         If DoesUserExist(sUserName) Then
  305.             'This user already exists, inform the person so they can try a new name
  306.             lNewMsg = Msg_UserAlreadyExists
  307.             lNewOffSet = NewBuffer(oNewMsg)
  308.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  309.             dps.SendTo .idSender, oNewMsg, 0, 0
  310.         Else
  311.             'Great, this username doesn't exist.  Now lets add this user
  312.             AddUser sUserName, sPass, .idSender
  313.             'We don't need to inform anyone we are logged on, because
  314.             'no one could have us listed as a friend yet
  315.             
  316.             'Notify the user they logged on successfully
  317.             lNewMsg = Msg_LoginSuccess
  318.             lNewOffSet = NewBuffer(oNewMsg)
  319.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  320.             dps.SendTo .idSender, oNewMsg, 0, 0
  321.             
  322.             'Increment our user count
  323.             glNumPlayers = glNumPlayers + 1
  324.             'Add this user to our list of users currently online
  325.             lstUsers.AddItem sUserName & " 0x" & Hex$(.idSender)
  326.             lstUsers.ItemData(lstUsers.ListCount - 1) = .idSender
  327.             UpdateText "Server running...  (" & CStr(glNumPlayers) & "/1000 clients connected.)"
  328.         End If
  329.     Case Msg_Login 'They have requested a login, check name/password
  330.         sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
  331.         sPass = GetStringFromBuffer(.ReceivedData, lOffset)
  332.         Select Case LogonUser(sUserName, sPass) 'Try to log on the user
  333.         Case LogonSuccess 'Great, they logged on
  334.             UpdateDBToShowLogon sUserName, dpnotify.idSender 'Update the DB to show I'm online
  335.             'Notify the user they logged on successfully
  336.             lNewMsg = Msg_LoginSuccess
  337.             lNewOffSet = NewBuffer(oNewMsg)
  338.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  339.             dps.SendTo .idSender, oNewMsg, 0, 0
  340.             mfLogonTimer = True
  341.             msLogonName = sUserName
  342.             'Increment our user count
  343.             glNumPlayers = glNumPlayers + 1
  344.             'Add this user to our list of users currently online
  345.             lstUsers.AddItem sUserName & " 0x" & Hex$(.idSender)
  346.             lstUsers.ItemData(lstUsers.ListCount - 1) = .idSender
  347.             UpdateText "Server running...  (" & CStr(glNumPlayers) & "/1000 clients connected.)"
  348.             
  349.         Case InvalidPassword 'Let the user know that they didn't type in the right password
  350.             'Notify the user they sent the wrong password
  351.             lNewMsg = Msg_InvalidPassword
  352.             lNewOffSet = NewBuffer(oNewMsg)
  353.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  354.             dps.SendTo .idSender, oNewMsg, 0, 0
  355.         Case AccountDoesNotExist 'Let the user know this account isn't in the DB
  356.             'Notify the user that this account doesn't exist
  357.             lNewMsg = Msg_InvalidUser
  358.             lNewOffSet = NewBuffer(oNewMsg)
  359.             AddDataToBuffer oNewMsg, lNewMsg, LenB(lNewMsg), lNewOffSet
  360.             dps.SendTo .idSender, oNewMsg, 0, 0
  361.         End Select
  362.     Case Msg_SendMessage 'They are trying to send a message to someone
  363.         sUserName = GetStringFromBuffer(.ReceivedData, lOffset)
  364.         sFromMsg = GetStringFromBuffer(.ReceivedData, lOffset)
  365.         sChatMsg = GetStringFromBuffer(.ReceivedData, lOffset)
  366.         SendMessage sUserName, sFromMsg, sChatMsg
  367.     End Select
  368.     End With
  369. End Sub
  370. Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
  371.     'VB requires that we must implement *every* member of this interface
  372. End Sub
  373. Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
  374.     'VB requires that we must implement *every* member of this interface
  375. End Sub
  376.